home *** CD-ROM | disk | FTP | other *** search
/ MacWorld UK 2000 March / MW_UK_2000_03.iso / Shareware World / Utilities / Text Processing / Alpha / Tcl / SystemCode / modes.tcl < prev    next >
Encoding:
Text File  |  1999-11-09  |  17.5 KB  |  636 lines  |  [TEXT/ALFA]
  1. # (nowrap)
  2.  
  3. namespace eval mode {}
  4. namespace eval win {}
  5. namespace eval menu {}
  6.  
  7. # ◊◊◊◊ Declare Alpha packages ◊◊◊◊ #
  8.  
  9. # This procedure is not yet final.  Please do not rely on its API for
  10. # use outside of Alpha's core.  Changes may be made to streamline Alpha's
  11. # package initialisation and declaration process.
  12. proc alpha::declare {what name version modes {initialise ""} {activate ""} {deactivate ""} args} {
  13.     global alpha::rebuilding
  14.     if {!${alpha::rebuilding}} {return}
  15.     global index::feature rebuild_cmd_count
  16.     if {[string trim "$initialise$activate$deactivate"] == ""} {
  17.     set index::feature($name) [list $version $modes -1]
  18.     } else {
  19.     switch -- $what {
  20.         "feature" {
  21.         set init 0
  22.         }
  23.         "menu" {
  24.         set init 1
  25.         }
  26.         "flag" {
  27.         set init 2
  28.         }
  29.         "autofeature" {
  30.         set init 3
  31.         }
  32.         default {
  33.         error "Bad alpha::declare type '$what'"
  34.         }
  35.     }
  36.     set index::feature($name) [list $version $modes $init $initialise $activate $deactivate]
  37.     }
  38.     if {[llength $args]} {
  39.     eval alpha::package [lindex $args 0] $name $version [lrange $args 1 end]
  40.     return
  41.     }
  42.     if {[info exists rebuild_cmd_count] && [incr rebuild_cmd_count -1] == 0} {
  43.     return -code 11
  44.     }
  45. }
  46.  
  47. proc alpha::feature {name version modes {initialise ""} {activate ""} {deactivate ""} args} {
  48.     uplevel 1 [list alpha::declare feature $name $version $modes \
  49.       $initialise $activate $deactivate] $args
  50. }
  51.  
  52. proc alpha::flag {name version modes args} {
  53.     uplevel 1 [list alpha::declare flag $name $version $modes \
  54.       "set $name 0" "set $name 1" "set $name 0"] $args
  55. }
  56.  
  57. proc alpha::extension {name version {script ""} args} {
  58.     uplevel 1 [list alpha::declare feature $name $version "global-only" "" $script ""] $args
  59. }
  60.  
  61. proc alpha::menu {name version modes {value ""} {initialise ""} {activate ""} {deactivate ""} args} {
  62.     global alpha::rebuilding
  63.     if {!${alpha::rebuilding}} {
  64.     # This is required when autoloading some procs without activating
  65.     # a menu
  66.     global $name
  67.     ensureset $name $value
  68.     return
  69.     }
  70.     if {[regexp {^•} [string index $modes 0]]} {
  71.     # it's in the old format
  72.     set tmp $modes
  73.     set modes $value
  74.     if {$modes == "in_menu"} { set modes "global" }
  75.     set value $tmp
  76.     # perhaps there's a better way of collapsing these arguments
  77.     if {[llength $args]} {
  78.         set args [concat [list $activate $deactivate] $args]
  79.     } else {
  80.         if {$deactivate != ""} {
  81.         lappend activate $deactivate
  82.         set args $activate
  83.         } else {
  84.         set args $activate
  85.         }
  86.     }    
  87.     set activate "$name"
  88.     set deactivate ""
  89.     }
  90.     uplevel 1 [list alpha::declare menu $name $version $modes \
  91.       "ensureset $name $value\n$initialise" $activate $deactivate] $args
  92. }
  93.  
  94. proc alpha::mode {name version dummyProc {ext ""} {menus ""} {script ""} args} {
  95.     global alpha::rebuilding alpha::requirements
  96.     if {!${alpha::rebuilding}} {return}
  97.     namespace eval ::$name {}
  98.     global index::mode rebuild_cmd_count index::oldmode
  99.     set index::mode($name) [list $version $dummyProc [join $ext " "] $menus $script]
  100.     if {[info exists index::oldmode($name)]} {
  101.     if {[set omenus [lindex [set index::oldmode($name)] 3]] != $menus} {
  102.         global alpha::noMenusYet mode::features modifiedArrayElements
  103.         foreach m $menus {
  104.         # Store all version number requirements
  105.         if {[lindex $m 2] != ""} {
  106.             lappend alpha::requirements [list $name $m]
  107.         }
  108.         set mm [lindex $m 0]
  109.         if {([lsearch -exact $omenus $mm] == -1) \
  110.           && ([lsearch -glob $omenus "$mm *"] == -1)} {
  111.             # it's new
  112.             package::addRelevantMode $mm $name
  113.             if {[lindex $m 1] == 0} {continue}
  114.             if {[info exists alpha::noMenusYet]} {
  115.             # we added a feature 
  116.             hook::register startupHook "lunion mode::features($name) $mm"
  117.             } else {
  118.             lunion mode::features($name) $mm
  119.             lappend modifiedArrayElements [list $name mode::features]
  120.             }
  121.         }
  122.           
  123.         }
  124.         foreach om $omenus {
  125.         set omm [lindex $om 0]
  126.         if {([lsearch -exact $menus $omm] == -1) \
  127.           && ([lsearch -glob $menus "$omm *"] == -1)} {
  128.             # it has been removed from the default list
  129.             package::removeRelevantMode $omm $name
  130.             set mode::features($name) [lremove $mode::features($name) $omm]
  131.             lappend modifiedArrayElements [list $name mode::features]
  132.         }
  133.         }
  134.     }
  135.     }
  136.     if {[llength $args]} {
  137.     eval alpha::package [lindex $args 0] $name $version [lrange $args 1 end]
  138.     return
  139.     }
  140.     if {[info exists rebuild_cmd_count] && [incr rebuild_cmd_count -1] == 0} {
  141.     return -code 11
  142.     }        
  143. }
  144.  
  145. ## 
  146.  # -------------------------------------------------------------------------
  147.  # 
  148.  # "addMode" -- you probably won't call this proc yourself
  149.  # 
  150.  # -------------------------------------------------------------------------
  151.  ##
  152. proc addMode {m dummy suffs _features} {
  153.     global mode::features filepats dummyProc index::feature
  154.     namespace eval ::$m {}
  155.     if {[string length $dummy]} {set dummyProc($m) $dummy}
  156.     ensureset mode::features($m) $_features
  157.     foreach f $_features {
  158.     package::addRelevantMode $f $m
  159.     }
  160.     ensureset filepats($m) $suffs
  161. }
  162.  
  163. proc addMenu {name {val ""} {modes ""}} {
  164.     global menus index::feature
  165.     lunion menus $name
  166.     if {$val != ""} {
  167.     global $name
  168.     if {![info exists $name]} { set $name $val }
  169.     }
  170.     if {[info exists index::feature($name)]} {
  171.     eval lappend modes [lindex [set index::feature($name)] 1]
  172.     }
  173.     set index::feature($name) \
  174.       [list [list "mode" [lindex $modes 0]] $modes 1 "" $name ""]
  175. }
  176.  
  177.  
  178. # ◊◊◊◊ Procs Alpha calls directly ◊◊◊◊ #
  179. proc getModeValuesAlpha {} {
  180.     global showInvisibles
  181.     
  182.     getWinInfo blah
  183.     lappend m "Mac" [expr {$blah(platform) == "mac"}]
  184.     lappend m "UNIX" [expr {$blah(platform) == "unix"}]
  185.     lappend m "IBM" [expr {$blah(platform) == "ibm"}] {(-} 0
  186.     lappend m "MPW" [expr {$blah(state) == "mpw"}]
  187.     lappend m "Think" [expr {$blah(state) == "think"}]
  188.     lappend m "None" [expr {$blah(state) == "none"}] {(-} 0
  189.     lappend m "Read Only" $blah(read-only)
  190.     lappend m "Show Invisibles" $showInvisibles {(-} 0
  191.     lappend m "Tab Size" 0
  192.     return $m
  193. }
  194.  
  195.  
  196. proc setModeVarAlpha {var} {
  197.     global mode allFlags modeVars
  198.     global ${mode}modeVars
  199.     
  200.     set var [string tolower $var]
  201.     switch -- $var {
  202.         "unix"      -
  203.         "mac"       -
  204.         "ibm"       { setWinInfo platform $var ; setWinInfo dirty 1 }
  205.         "mpw"       -
  206.         "think"     -
  207.         "none"      { setWinInfo state $var }
  208.         "tab size"  {
  209.             getWinInfo arr
  210.             if {![catch {prompt "New tab size?" $arr(tabsize)} res]} {
  211.                 setWinInfo tabsize $res
  212.             }
  213.         }
  214.         "read only" { 
  215.             getWinInfo b
  216.             setWinInfo read-only [expr {-1 * ($b(read-only) - 1)}]}
  217.         "show invisibles" { 
  218.             global showInvisibles
  219.             set showInvisibles [expr {1 - $showInvisibles}]
  220.         }
  221.     }
  222.     return
  223. }
  224.  
  225. ## 
  226.  # -------------------------------------------------------------------------
  227.  # 
  228.  # "modes" --
  229.  # 
  230.  #  Called to get the list of modes for the modes popup
  231.  # -------------------------------------------------------------------------
  232.  ##
  233. proc modes {args} { 
  234.     global mode::features
  235.     return [lsort -ignore [array names mode::features]]
  236. }
  237.  
  238. # Called from alpha in response to the mode popup.
  239. proc newMode {mode} {
  240.     if {[package::helpOrDescribe $mode]} { return }
  241.     global win::Modes
  242.     changeMode $mode
  243.     if {[catch {win::Current} name]} return
  244.     set win::Modes($name) $mode
  245.     refresh
  246. }
  247.  
  248. # ◊◊◊◊ Mode specific items ◊◊◊◊ #
  249.  
  250. proc mode::menuProc {menu item} {
  251.     if {![llength [winNames]]} {
  252.         alertnote "No window!"
  253.         return
  254.     }
  255.     switch -- $item {
  256.         "preferences"       dialog::modifyModeFlags
  257.         "loadPrefsFile"     mode::sourcePrefsFile
  258.         "describeMode"      mode::describe
  259.         "changeMode"            mode::changeDialog
  260.     default {
  261.         mode::$item
  262.     }        
  263.     }
  264. }
  265.  
  266. ## 
  267.  # -------------------------------------------------------------------------
  268.  #     
  269.  # "win::setMode"    --
  270.  #    
  271.  #    Copes with endings like    '.orig'
  272.  #    or the backup ending '~' or ' copy', and checks a smart-mode line
  273.  #    like emacs, and handles a few Alpha-specific windows (trace dumps).
  274.  #
  275.  # -------------------------------------------------------------------------
  276.  ##
  277. proc win::setMode name {
  278.     global win::Modes
  279.     set win::Modes($name) [file::whichModeForWin $name]
  280. }
  281.  
  282.  
  283. ## 
  284.  # -------------------------------------------------------------------------
  285.  # 
  286.  # "win::addToMenu" --
  287.  # 
  288.  #  Adds a window name to the window menu.  This new version adds a 
  289.  #  binding, to work-around a bug in Alpha, so that using cmd-0-9
  290.  #  works if the window name contains square brackets.  The problem
  291.  #  is that the 'addMenuItem' line creates a binding of the form
  292.  #  'menu::winProc •263 namewith[square]brackets' which when evaluated
  293.  #  causes an error.  We force a separate binding to
  294.  #  'menu::winProc •263 {namewith[square]brackets}' which does work.
  295.  # -------------------------------------------------------------------------
  296.  ##
  297. proc win::addToMenu {name} {
  298.     global winNameToNum winMenu winNumToName
  299.     if {[info tclversion] < 8.0} {
  300.     set name [subst $name]
  301.     }
  302.     
  303.     for {set i 0} {$i<100} {incr i} {
  304.     if {![info exists winNumToName($i)]} {
  305.         regsub { <[0-9]+>$} $name {} nm
  306.         if {[file exists $nm]} {
  307.         set nm [file tail $name]
  308.         } else {
  309.         set nm $name
  310.         }
  311.         if {$i < 10} {
  312.         addMenuItem -m -l "/$i" $winMenu "$nm"
  313.         if {[info tclversion] < 8.0} {
  314.             Bind '$i' <c> [list menu::winProc $winMenu $nm]
  315.         }
  316.         } else {
  317.         addMenuItem -m -l "" $winMenu "$nm"
  318.         }
  319.         set winNumToName($i) $name
  320.         set winNameToNum($name) $i
  321.         return
  322.     }
  323.     }
  324. }
  325.  
  326. proc win::removeFromMenu {name} {
  327.     global winNameToNum winNumToName winMenu
  328.     if {[info tclversion] < 8.0} {
  329.     set name [subst $name]
  330.     }
  331.     set num $winNameToNum($name)
  332.     unset winNumToName($num)
  333.     unset winNameToNum($name)
  334.     regsub { <[0-9]+>$} $name {} nm
  335.     if {[file exists $nm]} {
  336.     set nm [file tail $name]
  337.     } else {
  338.     # in case it was a file but the file was actually moved!
  339.     global file::separator tcl_platform
  340.     if {[regexp "\[^${file::separator}\]+\$" $name nm]} {
  341.         if {![catch {deleteMenuItem -m $winMenu $nm}]} { return } 
  342.     }
  343.     if {$tcl_platform(platform) == "windows"} {
  344.         if {[regexp "\[^\\\\\]+\$" $name nm]} {
  345.         if {![catch {deleteMenuItem -m $winMenu $nm}]} { return } 
  346.         }
  347.     }
  348.     set nm $name
  349.     }
  350.     # to handle alpha problem with rebuilding the menu
  351.     if {[catch {deleteMenuItem -m $winMenu $nm}]} { deleteMenuItem $winMenu $nm }
  352. }
  353.  
  354. proc mode::changeDialog {} {
  355.     global mode mode::features
  356.  
  357.     set nmode [listpick -p "Mode:" -L $mode \
  358.       [lsort -ignore [array names mode::features]]]
  359.     newMode $nmode
  360. }
  361.  
  362. proc mode::describe {} {
  363.     global mode ModeSuffixes mode::features
  364.     global ${mode}modeVars
  365.     
  366.     set text "\r\tMODE $mode\r\r"
  367.     if {![catch {package::describe $mode 1} res]} {
  368.     append text $res "\r\r"
  369.     }
  370.  
  371.     set tmp ""
  372.     catch {set tmp [package::helpFile $mode 1]}
  373.     append text "$tmp\r\r"
  374.  
  375.     set suffs ""
  376.     set first 1
  377.     foreach suf $ModeSuffixes {
  378.         if {([llength $suf] == 3) && ([lindex $suf 1] == "winMode") \
  379.       && ([lindex $suf 2] == $mode)} {
  380.         if {$first} {
  381.         append suffs $last
  382.         set first 0
  383.         } else {
  384.                 append suffs ", $last"
  385.             }
  386.         }
  387.         set last $suf
  388.     }
  389.     append text "Mode filepats: " $suffs "\r\r"
  390.     
  391.     set first 1
  392.     append text "Mode menus and features: "
  393.     if {[info exists mode::features($mode)]} {
  394.         foreach m [set mode::features($mode)] {
  395.             if {$first} {
  396.                 set first 0
  397.                 append text $m
  398.             } else {
  399.                 append text ", " $m
  400.             }
  401.         }
  402.      }
  403.     append text "\r\r"
  404.     append text [mode::describeVars $mode]
  405.     
  406.     set etext "\rMode-independent bindings:\r"
  407.     append text "\rMode-specific bindings:\r"
  408.     foreach b [split [bindingList] "\r"] {
  409.     set lst [lindex [split $b  " "] end]
  410.         if {$lst == $mode} {
  411.             append text "\t$b\r"
  412.         }
  413.     }
  414.     append text "\rTo list mode-independent bindings, select\
  415.       'List Global/All Bindings'\rfrom the Config menu.\r"
  416.     new -n "* <$mode> MODE *" -m Tcl -text $text -shell 1 -read-only 1
  417. }
  418.  
  419. proc mode::describeVars {pkg {pkgpref ""}} {
  420.     cache::readContents index::prefshelp
  421.     if {$pkgpref == ""} {set pkgpref $pkg}
  422.     global ${pkgpref}modeVars
  423.     append text "Package-specific variables:\r"
  424.     if {[array exists ${pkgpref}modeVars]} {
  425.     foreach v [lsort [array names ${pkgpref}modeVars]] {
  426.         set val [set ${pkgpref}modeVars($v)]
  427.         global flag::type
  428.         set description ""
  429.         if {[info exists prefshelp(${pkg},$v)]} {
  430.         set description [dialog::helpdescription $prefshelp(${pkg},$v)]
  431.         } elseif {[info exists prefshelp(${pkgpref},$v)]} {
  432.         set description [dialog::helpdescription $prefshelp(${pkgpref},$v)]
  433.         } elseif {[info exists prefshelp($v)]} {
  434.         set description [dialog::helpdescription $prefshelp($v)]
  435.         }
  436.         
  437.         if {$description != ""} {
  438.         regsub -all "\[\r\n\]" [breakIntoLines $description] "&  \# " description
  439.         append text "  # " $description "\r"
  440.         }
  441.         if {[info exists flag::type($v)] \
  442.           && [regexp {binding$} [set flag::type($v)]]} {
  443.         set val [dialog::specialView_binding $val]
  444.         }
  445.         append text [format "  %-20s: \"%s\"\r" $v $val]
  446.     }
  447.     }
  448.     
  449.     return $text
  450. }
  451.  
  452. # Now calls the new proc dialog::pickMenus
  453. proc mode::menusAndFeatures {} {
  454.     global mode mode::features modifiedArrayElements global::features
  455.  
  456.     set newFeatures [dialog::pickMenusAndFeatures $mode]
  457.     set offon [package::onOrOff $newFeatures $mode]
  458.     
  459.     set mode::features($mode) $newFeatures
  460.     lappend modifiedArrayElements [list $mode mode::features]
  461.     # deactivate removed items
  462.     foreach m [lindex $offon 0] {
  463.     package::deactivate $m
  464.     }
  465.     foreach m [lindex $offon 1] {
  466.     package::activate $m
  467.     }
  468. }
  469.  
  470. if {[info tclversion] < 8.0} {
  471. proc mode::proc {name args} {
  472.     global mode
  473.     if {[info commands ${mode}::$name] != ""} {
  474.     eval ${mode}::$name $args
  475.     } else {
  476.     eval ::$name $args
  477.     }
  478. }
  479. proc mode::getProc {name} {
  480.     global mode
  481.     if {[info commands ${mode}::$name] != ""} {
  482.     return ${mode}::$name
  483.     } else {
  484.     return ""
  485.     }
  486. }
  487. proc mode::getVar {var} {
  488.     uplevel \#0 "
  489.     if \[info exists \${mode}::$var\] { 
  490.     return \[set \${mode}::$var\]
  491.     } else {
  492.     return \[set $var\]
  493.     } \
  494.       "
  495. }
  496.  
  497. } else {
  498.     proc mode::proc {name args} {
  499.     global ::mode
  500.     namespace eval ::$mode "$name $args"
  501.     }
  502.     proc mode::getProc {name} {
  503.     global ::mode
  504.     namespace eval ::$mode "namespace which $name"
  505.     }
  506.     proc mode::getVar {var} {
  507.     uplevel \#0 "
  508.     if \[info exists ::\${mode}::$var\] { 
  509.         return \[set ::\${mode}::$var\]
  510.     } else {
  511.         return \[set ::$var\]
  512.     } \
  513.       "
  514.     }
  515. }
  516.  
  517. # Suffixes used to determine mode for new windows.
  518. proc mode::updateSuffixes {} {
  519.     global ModeSuffixes mode::features filepats
  520.  
  521.     set ModeSuffixes { default { set winMode Text } }
  522.     foreach m [lsort -ignore [array names mode::features]] {
  523.         if {[info exists filepats($m)]} {
  524.         lappend ModeSuffixes $filepats($m) "set winMode $m"
  525.         }
  526.     }
  527. }
  528.  
  529. proc synchroniseModeVar {var args} {
  530.     global mode $var
  531.     if {[llength $args] > 0} {
  532.     set $var [lindex $args 0]
  533.     }
  534.     global ${mode}ModeVars modifiedArrayElements
  535.     lappend modifiedArrayElements [list $var ${mode}modeVars]
  536.     set ${mode}modeVars($var) [set $var]
  537. }
  538.  
  539. # ◊◊◊◊ Miscellaneous ◊◊◊◊ #
  540.  
  541. proc alpha::tryToLoad {msg args} {
  542.     message "${msg}…"
  543.     set i -1
  544.     set ok 1
  545.     while 1 {
  546.     set do [lindex $args [incr i]]
  547.     set say [lindex $args [incr i]]
  548.     if {$say == ""} {
  549.         set say "Loading $do"
  550.     }
  551.     if {$do == ""} {
  552.         if {$ok} {
  553.         message "${msg}…Complete."
  554.         } else {
  555.         alertnote "${msg}…Failed."
  556.         }
  557.         return $ok
  558.     }
  559.     message "${say}…"
  560.     if {[catch $do err]} {
  561.         if {[dialog::yesno -y "View the error" -n "Continue" \
  562.           "$say failed!"]} {
  563.         global errorInfo
  564.         dialog::alert "$errorInfo"
  565.         }
  566.     }
  567.     }
  568. }
  569.  
  570. # ◊◊◊◊ Read in all the packages ◊◊◊◊ #
  571.  
  572. proc alpha::getBasicModes {} {
  573.     global PSwords
  574.     addMode PS {} {*.ps *.eps *.epsf} {}
  575.     newPref v prefixString {% } PS
  576.     set PSKeyWords {
  577.     def begin end dict load exec if ifelse for repeat loop exit 
  578.     stop stopped countexecstack execstack quit start gsave 
  579.     grestore grestoreall initgraphics newpath erasepage fill 
  580.     eofill stroke image imagemask showpage copypage
  581.     }
  582.     if {[info exists PSwords]} {set PSKeyWords [concat $PSKeyWords $PSwords]}
  583.     regModeKeywords -e {%} -m {/}  -c red -k blue PS $PSKeyWords -i "\}" -i "\{" -i "\[" -i "\]" -I green
  584.     
  585.     addMode Inst "" [list "*Install" "*INSTALL"] {installMenu}
  586.     addMenu installMenu "Install"
  587.     hook::register openHook install::openHook Inst
  588.     
  589.     addMode Text {} {default} {}
  590.     newPref v leftFillColumn {0} Text
  591.     newPref v suffixString { <--} Text
  592.     newPref v prefixString {> } Text
  593.     newPref v fillColumn {75} Text
  594.     newPref f wordWrap {1} Text
  595.     newPref v wordBreak {\w+} Text
  596.     newPref v wordBreakPreface {(\W)} Text
  597.     newPref v wrapBreak {[\w_]+} Text
  598.     newPref v wrapBreakPreface {([^\w_])} Text
  599.     newPref f autoMark 0 Text
  600.     newPref flag quietlyClearMarks 0 Text
  601.     namespace eval Text {}
  602.     proc Text::DblClick {args} {
  603.     eval Tcl::DblClick $args
  604.     }
  605. }
  606.  
  607. proc alpha::findAllPlugins {} {
  608.     alpha::findAllModes
  609.     global skipPrefs
  610.     if {!$skipPrefs} {
  611.     alpha::findAllExtensions
  612.     }
  613. }
  614.  
  615. proc alpha::findAllModes {} {
  616.     alpha::getBasicModes
  617.     rename alpha::getBasicModes {}
  618.     cache::readContents index::mode
  619.     foreach f [array names index::mode] {
  620.     eval addMode $f [lrange [set index::mode($f)] 1 3]
  621.     if {[set script [lindex [set index::mode($f)] 4]] != ""} {
  622.         if {[catch {uplevel #0 $script} err]} {
  623.         lappend problems "$f"
  624.         }
  625.     }
  626.     }
  627.     if {[info exists problems]} {
  628.     alertnote "Problems loading modes: $problems"
  629.     }
  630.     mode::updateSuffixes
  631. }
  632.  
  633.  
  634.  
  635.  
  636.